

;; iconobj2.lsp
;; contains code to implement icon objects for the structured GUI
;; this file has icon drawing code for icon-proto and for 
;; all code for graph and stats icon object and it's bitmaps and methods
;; including transf and analy icons
;;=========================================================================
;; Copyright (c) 1992-2002 by Forrest W. Young



(SETF NDRAWSICON 0)

(defmeth icon-proto :show-icon (state &key (draw t))
(when (not (send self :deleted?))
  (let* ((icon-type (send self :icon-type))
         (data-type) (data-icon) (model-icon)
         (icon-cap)
         (action)
         (multi-color? t)
         (graph-button-state (or (send self :graph-ever-shown?) (send self :graph-hilited)))
         (stats-button-state (or (send self :stats-ever-shown?) (send self :stats-hilited)))
         (trans-button-state (or (send self :trans-ever-shown?) (send self :trans-hilited)))
         (model-button-state (or (send self :model-ever-shown?) (send self :model-hilited)))
         (w (send self :window))
         (x (send self :x))
         (y (send self :y))
         (toolbar-bottom (+ 34 (second (send w :scroll))))
         (title (send self :title))
         (new-style? (send w :new-icon-style?))
         (ears? (send w :show-icon-ears?))
         (selected? (equal state "selected"))
         (froze? (send self :freeze))
         (object (send self :object))
         (back-color (send w :back-color))
         (draw-color (send w :draw-color)))
(SETF NDRAWSICON (1+ NDRAWSICON))
    (when (or (not (send w :gui)) 
              (send w :postpone-redraw)
               )
          (setf draw nil))
;(format T "; ICONOBJ1:SHOW-ICON ~D ICON: ~a~%" ndrawsicon title)
    (when (and object 
               (or (= 1 icon-type) (< 2 icon-type 6)))
          (when (and (send object :has-slot 'missing-values)
                     (send object :missing-values))
                (send self :graph-not-showable t)
                (send self :stats-not-showable t)))
    (when froze? (setf state (send self :state)))
    (send self :icon-state-changing (not (equal state (send self :state))))
    (cond 
      ((and (not (send self :undrawn))
            (send self :icon-state-changing)
            (not (send self :title-back-color))
            (< (- toolbar-bottom 30) y toolbar-bottom))
       (send self :undrawn t))
      (t
       (send self :undrawn nil)
       (when (and draw icon-type)
          (when (send w :use-color)
                (send w :back-color 'white)


; icon-type: 1 data 2 analysis 3 model 4 dissim 5 table 6-8 guide tools 9 dash


                (cond
                  ((or (= 1 icon-type) (< 2 icon-type 6));data and model icons 
                   (if (= 3 icon-type)
                       (send w :draw-color 'model-icon-color)
                       (send w :draw-color 'data-icon-color))
                   (cond 
                     ((not multi-color?)
                      (if (equal state "normal") 
                          (send w :draw-bitmap (send self :icon) x y)
                          (send w :draw-bitmap (send self :hi-icon) x y)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
                     (t
                      (cond
                        ((= icon-type 1) ;data
                         (setf data-type (send (send self :object) :data-type))
                         (cond
                           ((equal state "normal")
                            (send w :back-color 'white)
                            (send w :draw-color 'gray))
                           (t
                            (send w :back-color 'white)
                            (send w :draw-color (if (equal data-type "missing")
                                                    'yellow
                                                    (send self :icon-color)))))
                         )
                        ((= icon-type 4)
                         (send w :draw-color 'dissim-icon-color))
                         ((= icon-type 3) ;model-icon
                         (setf data-icon 
                               (if object
                                   (select (send w :icon-list) 
                                           (1- (send object :icon-number)))
                                   self))
                         (if (equal state "normal")
                             (send w :draw-complex-bitmap (send data-icon :icon) 
                                   x y state icon-type (send self :icon-cap))
                             (send w :draw-complex-bitmap (send data-icon :hi-icon)
                                   x y state icon-type (send self :hi-icon-cap)))))
                      (when (or (= icon-type 1) (= icon-type 4))
                            (setf trans-icon-button nil)
                            (setf model-icon-button nil)
                            (if (equal state "normal") 
                                (send w :draw-complex-bitmap 
                                      (send self :icon) x y state icon-type icon-cap)
                                (send w :draw-complex-bitmap 
                                      (send self :hi-icon) x y state icon-type icon-cap))

                            )
                      ))      
                   (send self :draw-trans-icon 
                         (and selected? trans-button-state) 
                         (send self :trans-ever-shown?))
                   (send self :draw-graph-icon (and selected? graph-button-state)
                         (send self :graph-ever-shown?))
                   (send self :draw-model-icon (and selected? model-button-state)
                         (send self :model-ever-shown?))
                   (send self :draw-stats-icon (and selected? stats-button-state)
                         (send self :stats-ever-shown?))
                   )
                  ((or (= 2 icon-type) (< 5 icon-type 9));tool icons
                   (case icon-type
                     (2 (send w :draw-color 'tool-icon-color))
                     (6 (send w :draw-color 'guide-icon-color))
                     (7 (send w :draw-color 'black))
                     (8 (send w :draw-color 'blue)))
                   (when (equal state "normal")   
                         (setf bmp (send self :icon)))
                   (when (or (equal state "gray") (equal state "grey"))
                         (send w :draw-color 'never-shown-color) 
                                 (setf bmp (send self :grey-icon)) ;icon
                         )
                   (when (or (equal state "hilited")
                             (equal state "selected"))
                         (setf bmp (send self :hi-icon)))
                   (send w :draw-bitmap bmp x y)
                   (send w :back-color back-color)
                   )
                  ((> icon-type 8)
                   (cond
                     ((equal state "normal") (send self :draw-icon x y))
                     ((or (equal state "hilited") 
                          (equal state "selected")) (send self :draw-hi-icon x y))
                     ((or (equal state "gray") 
                          (equal state "grey")) (send self :draw-grey-icon x y))
                     )))
                (send w :draw-color 'black)
                (send self :draw-title state)
                (send w :back-color back-color)
                (send w :draw-color draw-color)
                (when (< icon-type 9) (send self :draw-shadows))
                (when (or (= 1 icon-type) (< 2 icon-type 6))
                      (if (= icon-type 3)
                          (if (equal state "selected")
                              (send w :draw-color 'model-icon-cap-color)
                              (send w :draw-color 'weak-model-icon-cap-color));
                          (if (equal state "selected")
                              (send w :draw-color 'data-icon-cap-color)
                              (send w :draw-color 'weak-data-icon-cap-color)))
                      (send w :paint-rect (+ 1 x) (+ 1 y) 22 7)
                      (send w :draw-color 'black)
                      (send w :back-color 'white)
                      )
                (when (or (= 1 icon-type) (< 3 icon-type 6))
                      (send w :draw-color 'data-icon-cap-color)
                      (send w :paint-rect (+ 1 x) (+ 1 y) 22 7)
                      (send w :draw-color 'black)
                      (send w :back-color 'white)
                      )
                ))))
   ; (send self :draw-overlapping-titles x y)
    (when (send self :icon-state-changing)
          (send self :icon-state state)
          (send self :icon-state-changing nil))
    (send w :draw-color 'black)
;(one-button-dialog "SHOW ICON")
    t)))

(defmeth graph-proto :draw-complex-bitmap 
         (bitmatrix x y state icon-type &optional icon-cap)
"Draws data and model icons"
  (let* ((nrows (array-dimension bitmatrix 0))
         (ncols (array-dimension bitmatrix 1))
         (top (apply #'bind-rows (select (row-list bitmatrix) (iseq 8))))
         (edg (apply #'bind-rows (select (row-list bitmatrix) (list 8 ))));8 9
         (mid (apply #'bind-rows (select (row-list bitmatrix) (iseq 10 (- nrows 2)))));11
         (bot (apply #'bind-rows (select (row-list bitmatrix) (iseq (- nrows 2) (1- nrows)))))
         (dc (send self :draw-color))
         (bc (send self :back-color))
         )
    (when (or (equal state "hilited")
              (equal state "selected"))
          (send self :back-color 'black))
    (send self :draw-bitmap mid x (+ 10 y))
    (send self :draw-bitmap bot x (+ y (- nrows 2)))
    (send self :back-color 'white)
    (cond 
       (icon-cap
       (when (= icon-type 3) 
             (if (equal state "normal")
                 (send self :draw-color 'black)
                 (send self :draw-color 'model-icon-cap-color))
            ; (send self :draw-color 'model-icon-cap-color)
             (if (equal state "normal")
                 (send self :back-color 'model-icon-cap-color);white
                 (send self :back-color 'black)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

       (send self :draw-bitmap icon-cap x y)
       (send self :draw-color 'model-icon-cap-color)
       (when (equal state "normal")
             (send self :draw-bitmap edg x (+ 9 y)))
       (send self :draw-color 'black)


       (send self :draw-bitmap edg x (+ 8 y));9
       (send self :draw-bitmap edg x (+ 9 y));9
       (when (equal state "normal")
             (send self :draw-bitmap edg x (+ 9 y)));10
       )
      (t
       (send self :draw-color 'data-icon-cap-color)
       (send self :draw-bitmap top x y)
       (send self :back-color 'white)
       (send self :draw-color 'black)
       (send self :draw-bitmap edg x (+ 8 y))
       (send self :draw-bitmap edg x (+ 9 y))
       ))

   ; (if (equal state "normal")
   ;     (send self :draw-color 'workmap-background)
   ;     (send self :draw-color 'red))
   ; (send self :back-color 'workmap-background)
   ; (send self :draw-bitmap *checkmark-bitmap* (+ x 44) (+ y 9))
    (send self :back-color 'white)
    (send self :draw-color 'black)
    
    ))

;              (listeners)

(defmeth icon-proto :draw-shadows ()
  (let* ((size (array-dimensions (send self :icon)))
         (r (first size))
         (c (second size))
         (w (send self :window))
         (x (send self :x))
         (y (send self :y))
         (dc (send w :draw-color))
         )
  (send w :draw-color 'black)
  (send w :draw-bitmap (send self :shadowv) x y)
  (send w :draw-bitmap (send self :shadowh) x y)
  (send w :draw-bitmap (send self :shadowv) (+ x (1- c)) y)
  (send w :draw-bitmap (send self :shadowh) x (+ y (1- r)))
  (send w :draw-bitmap (send self :shadowv) (+ x c) (+ y 1))
  (send w :draw-bitmap (send self :shadowh) (+ x 1) (+ y r))
  (send w :draw-color dc)))

;  (LISTENERS)

(defmeth icon-proto :draw-title (&optional state)
  (send self :turn-title-off);fwy added 09-05-02
  (let* ((title (if (send self :title) (trimmed-title (send self :title)) "Untitled"))
         (elipsis-name (if (send self :object)
                           ;(send (send self :object) :elipsis-name)
                           (elipsis-name (send (send self :object) :proper-name))
                           (trimmed-title title)))
         (separation (send self :title-separation)) 
         (self-icon-title-color (send self :title-back-color))
         (icon-type (send self :icon-type))
         (outline nil)
         (all nil)
         (w (send self :window))
         (bc (send w :back-color))
         (dc (send w :draw-color))
         (w-icon-title-color (send w :icon-title-color))
         (title-color)
         (short (if (equal state "selected")
                    nil
                    (send w :short-icon-titles)))
         (L (length title))
         (x (+ (send self :x) (ceiling (/ (send self :width) 2))))
         (y (+ (send self :y) 1 (send self :height)))
         (vr (send w :vista-rect))
         (tw) (over-vista) (current-icon)
         (th (+ 1 (send w :text-ascent) (send w :text-descent)))
         (ih 0)
         (cflag)
         )
    (when (send w :calculate-vista-rect?)
          (send w :calculate-vista-rect)
          (send w :calculate-vista-rect? nil))
    (if (not state) (setf state (send self :state)))
    (when (not separation) (setf separation 1))
  
    (if w-icon-title-color
        (if self-icon-title-color 
            (setf title-color self-icon-title-color)
            (setf title-color 'white))
        (if self-icon-title-color
            (setf title-color self-icon-title-color)
            (setf title-color nil))) 
    (setf y (+ y separation -2))
    (when (and (not (= icon-type 2)) short) (setf title elipsis-name))
    (setf tw (ceiling (+ 1 (/ (send w :text-width title) 2))))
    (when (and (< (- (first vr) tw) (- x tw) (+ (first vr) (third vr)))
               (< (- (second vr) th) (+ 1 y) (+ th (second vr) (fourth vr))))
          (setf outline t)
          (if w-icon-title-color
              (setf title-color w-icon-title-color)
              (setf title-color 'workmap-background)))

    (when (or over-vista
              (equal state "hilited")
              (equal state "selected")) 
          (setf outline t)
          (setf title-color 'white))
    (when (and (not (equal w-icon-title-color 'white))
               (send self :icon-state-changing))
          (setf title-color 'white)
          (if self-icon-title-color
              (setf title-color self-icon-title-color)
              (when (equal state "normal")
                    (setf title-color 'workmap-background)
                    )))
    
    (when (equal title-color 'white) (setf outline t))
    (if (= 9 icon-type) (setf y (1- y)))
    (send w :draw-color title-color)
    (when (and (> y 40) 
               (or (equal state "hilited") (equal state "selected")))
          (send w :draw-color 'toolbar-background)
          (send w :line-width 2))
    (when title-color
          (send w :paint-rect (- x tw 1) y (+ 1 (* 2 (1+ tw))) (+ 0 th))
          (send w :draw-color 'black)
          (when outline
                (send w :frame-rect (- x tw 1) y (+ 1 (* 2 (1+ tw))) (+ 0 th)))
          )
    (setf cflag nil)
    (send w :line-width 1)
    (send w :draw-color 'black)
    (send w :draw-text title x y 1 1)
    (send w :draw-color dc)
    (send w :back-color bc)
    t))
	

(defun trimmed-title (title)
  (let* ((backtitle (reverse title)))
    (if (equal (select backtitle (iseq 2)) "1#")
        (select title (iseq (- (length title) 2)))
        title)))

(defmeth icon-proto :turn-title-off ()
  (when (or (equal self (select (send *workmap* :icon-list) 
                                (send *workmap* :selected-icon)))
           ; (equal self (select (send *workmap* :icon-list) 
           ;                      (send *workmap* :previously-selected-icon)))
            (equal (send self :state) "selected"))
        (let* ((title (trimmed-title (send self :title)));fwy changed 09-16-02
               (w (send self :window))
               (x (+ (send self :x) (ceiling (/ (send self :width) 2))))
               (y (+ (send self :y) (send self :height)))
               (tw (ceiling (+ 1 (/ (send w :text-width title) 2))))
               (th (+ (send w :text-ascent) (send w :text-descent))))
          (send w :draw-color 'workmap-background)
          (send w :paint-rect (- x tw 1) y (+ 1 (* 2 (1+ tw))) (+ 2 th)))))

(defmeth icon-proto :new-title-dialog ()
  (let* ((loc) (ds-title) (menu) (stats-object) (datasheet)
         (icon-type (send self :icon-type))
         (new-title (get-string-dialog "Enter New Title:" :initial (send self :title))))
    (when new-title
          (send self :title new-title)
          (send self :draw-title)
          (when (or (= 1 icon-type) (< 2 icon-type 6));data and model icons
                (setf stats-object (send self :object))
                (setf menu (if (= icon-type 3) *model-menu* *data-menu*))
                (send stats-object :name new-title)
                (set (intern (string-upcase new-title)) stats-object)
                (send (select (send menu :items) (send stats-object :menu-length)) 
                      :title new-title)
                (setf datasheet (send stats-object :datasheet-object))
                (when datasheet 
                      (setf loc (search-string " " (send datasheet :title)))
                      (when loc 
                            (setf ds-title 
                                  (strcat new-title (subseq (send datasheet :title) loc))))
                      (send datasheet :title ds-title))))))





;;=========================================================================
;;define prototype graph and stats icon object and it's bitmaps and methods
;;including transf and analy icons
;;=========================================================================

(defproto graph-stats-icon-proto 
  '() 
  nil icon-proto)

(defmeth  graph-stats-icon-proto :isnew 
  (w x y width height &key (title "Untitled") (state "gray") (draw t)
     (title-separation 2) (title-back-color nil))
(send self :null-icon #2A((1)))

(send self :graph-stats-grey-icon #2A(
(1 1 1 1 1 1 1 1 1 1 1 1 1 1 )  
(1 0 0 0 0 0 0 0 0 0 0 0 0 1 ) 
(1 0 1 0 1 0 1 0 1 0 1 0 0 1 ) 
(1 0 0 1 0 1 0 1 0 1 0 1 0 1 ) 
(1 0 1 0 1 0 1 0 1 0 1 0 0 1 ) 
(1 0 0 1 0 1 0 1 0 1 0 1 0 1 ) 
(1 0 1 0 1 0 1 0 1 0 1 0 0 1 ) 
(1 0 0 1 0 1 0 1 0 1 0 1 0 1 ) 
(1 0 1 0 1 0 1 0 1 0 1 0 0 1 ) 
(1 0 0 1 0 1 0 1 0 1 0 1 0 1 ) 
(1 0 1 0 1 0 1 0 1 0 1 0 0 1 ) 
(1 0 0 1 0 1 0 1 0 1 0 1 0 1 ) 
(1 0 0 0 0 0 0 0 0 0 0 0 0 1 ) 
(1 1 1 1 1 1 1 1 1 1 1 1 1 1 ))) ;14 14
  (send self :graph-icon #2A(
(1 1 1 1 1 1 1 1 1 1 1 1 1 1 ) 
(1 0 0 0 0 0 0 0 0 0 0 0 0 1 )
(1 0 1 1 0 0 0 0 0 0 0 1 0 1 ) 
(1 0 1 1 0 0 0 1 0 0 1 1 0 1 ) 
(1 0 1 1 0 1 0 0 0 1 1 0 0 1 ) 
(1 0 1 1 0 0 0 0 1 1 0 0 0 1 ) 
(1 0 1 1 0 0 0 1 1 1 1 0 0 1 ) 
(1 0 1 1 0 0 1 1 0 0 0 0 0 1 ) 
(1 0 1 1 0 1 1 0 1 1 0 0 0 1 ) 
(1 0 1 1 1 1 0 0 0 0 0 0 0 1 ) 
(1 0 1 1 1 1 1 1 1 1 1 1 0 1 ) 
(1 0 1 1 1 1 1 1 1 1 1 1 0 1 ) 
(1 0 0 0 0 0 0 0 0 0 0 0 0 1 ) 
(1 1 1 1 1 1 1 1 1 1 1 1 1 1 )));14
  (send self :graph-hi-icon #2A(
(1 1 1 1 1 1 1 1 1 1 1 1 1 1 ) 
(1 1 1 1 1 1 1 1 1 1 1 1 1 1 ) 
(1 1 0 0 1 0 1 1 1 1 0 1 1 1 ) 
(1 1 0 0 1 0 0 1 1 0 0 1 1 1 ) 
(1 1 0 0 1 1 1 1 0 0 1 1 1 1 ) 
(1 1 0 0 1 1 1 0 0 1 0 1 1 1 ) 
(1 1 0 0 1 1 0 0 1 0 0 1 1 1 ) 
(1 1 0 0 1 0 0 1 1 1 1 1 1 1 ) 
(1 1 0 0 0 0 1 1 0 0 1 1 1 1 ) 
(1 1 0 0 0 1 1 1 1 1 1 1 1 1 ) 
(1 1 0 0 0 0 0 0 0 0 0 0 1 1 ) 
(1 1 0 0 0 0 0 0 0 0 0 0 1 1 ) 
(1 1 1 1 1 1 1 1 1 1 1 1 1 1 )
(1 1 1 1 1 1 1 1 1 1 1 1 1 1 )));14
  (send self :stats-icon #2A(
(1 1 1 1 1 1 1 1 1 1 1 1 1 1 ) 
(1 0 0 0 0 0 0 0 0 0 0 0 0 1 )  
(1 0 0 1 1 1 1 1 1 1 1 0 0 1 ) 
(1 0 0 1 1 1 1 1 1 1 1 0 0 1 ) 
(1 0 0 1 1 1 0 0 0 1 1 0 0 1 ) 
(1 0 0 0 1 1 1 0 0 1 1 0 0 1 ) 
(1 0 0 0 0 1 1 0 0 0 0 0 0 1 ) 
(1 0 0 0 0 1 1 0 0 0 0 0 0 1 ) 
(1 0 0 0 1 1 1 0 0 1 1 0 0 1 ) 
(1 0 0 1 1 1 0 0 0 1 1 0 0 1 ) 
(1 0 0 1 1 1 1 1 1 1 1 0 0 1 ) 
(1 0 0 1 1 1 1 1 1 1 1 0 0 1 ) 
(1 0 0 0 0 0 0 0 0 0 0 0 0 1 ) 
(1 1 1 1 1 1 1 1 1 1 1 1 1 1 )));14
  (send self :stats-hi-icon #2A(
(1 1 1 1 1 1 1 1 1 1 1 1 1 1 ) 
(1 1 1 1 1 1 1 1 1 1 1 1 1 1 ) 
(1 1 1 0 0 0 0 0 0 0 0 1 1 1 ) 
(1 1 1 0 0 0 0 0 0 0 0 1 1 1 ) 
(1 1 1 0 0 0 1 1 1 0 0 1 1 1 ) 
(1 1 1 1 0 0 0 1 1 0 0 1 1 1 ) 
(1 1 1 1 1 0 0 0 1 1 1 1 1 1 ) 
(1 1 1 1 1 0 0 0 1 1 1 1 1 1 ) 
(1 1 1 1 0 0 0 1 1 0 0 1 1 1 ) 
(1 1 1 0 0 0 1 1 1 0 0 1 1 1 ) 
(1 1 1 0 0 0 0 0 0 0 0 1 1 1 ) 
(1 1 1 0 0 0 0 0 0 0 0 1 1 1 ) 
(1 1 1 1 1 1 1 1 1 1 1 1 1 1 ) 
(1 1 1 1 1 1 1 1 1 1 1 1 1 0 )));14
  (send self :trans-icon #2A(
(1 1 1 1 1 1 1 1 1 1 1 1 1 1 )  
(1 0 0 0 0 0 0 0 0 0 0 0 0 1 )  
(1 0 0 0 0 0 0 1 1 0 0 0 0 1 ) 
(1 0 0 0 0 0 0 1 1 0 0 0 0 1 ) 
(1 0 0 1 1 1 1 1 0 0 0 0 0 1 ) 
(1 0 0 1 1 1 1 1 1 1 1 0 0 1 ) 
(1 0 0 0 0 1 1 1 1 1 0 0 0 1 ) 
(1 0 0 0 0 1 1 0 0 0 0 0 0 1 )  
(1 0 0 0 1 1 0 0 0 0 0 0 0 1 ) 
(1 0 0 0 1 1 0 0 1 1 0 0 0 1 ) 
(1 0 0 0 1 1 1 1 1 1 0 0 0 1 ) 
(1 0 0 0 0 1 1 1 1 0 0 0 0 1 ) 
(1 0 0 0 0 0 0 0 0 0 0 0 0 1 ) 
(1 1 1 1 1 1 1 1 1 1 1 1 1 1 )));14x14
  (send self :trans-hi-icon #2A(
(1 1 1 1 1 1 1 1 1 1 1 1 1 1 ) 
(1 1 1 1 1 1 1 1 1 1 1 1 1 1 )  
(1 1 1 1 1 1 1 0 0 1 1 1 1 1 ) 
(1 1 1 1 1 1 0 0 1 1 1 1 1 1 ) 
(1 1 1 0 0 0 0 0 1 1 1 1 1 1 )  
(1 1 1 0 0 0 0 0 0 0 0 1 1 1 )  
(1 1 1 1 1 0 0 0 0 0 1 1 1 1 ) 
(1 1 1 1 1 0 0 1 1 1 1 1 1 1 ) 
(1 1 1 1 0 0 1 1 1 1 1 1 1 1 ) 
(1 1 1 1 0 0 1 1 1 0 0 1 1 1 ) 
(1 1 1 1 0 0 0 0 0 0 1 1 1 1 ) 
(1 1 1 1 1 0 0 0 0 1 1 1 1 1 )  
(1 1 1 1 1 1 1 1 1 1 1 1 1 1 ) 
(1 1 1 1 1 1 1 1 1 1 1 1 1 1 )));14x14
  (send self :model-icon #2A(
(1 1 1 1 1 1 1 1 1 1 1 1 1 1 ) 
(1 0 0 0 0 0 0 0 0 0 0 0 0 1 ) 
(1 0 0 0 0 0 0 0 0 0 0 0 0 1 ) 
(1 0 0 0 0 0 0 0 1 1 0 0 0 1 ) 
(1 0 0 1 1 0 0 1 1 1 1 0 0 1 ) 
(1 0 0 1 1 1 1 1 0 0 1 0 0 1 ) 
(1 0 0 0 1 1 1 0 0 0 0 0 0 1 ) 
(1 0 0 0 0 0 0 0 1 1 0 0 0 1 ) 
(1 0 0 1 1 0 0 1 1 1 1 0 0 1 ) 
(1 0 0 1 1 1 1 1 0 0 1 0 0 1 ) 
(1 0 0 0 1 1 1 0 0 0 0 0 0 1 ) 
(1 0 0 0 0 0 0 0 0 0 0 0 0 1 ) 
(1 0 0 0 0 0 0 0 0 0 0 0 0 1 ) 
(1 1 1 1 1 1 1 1 1 1 1 1 1 1 )));14x14
  (send self :model-hi-icon #2A(
(1 1 1 1 1 1 1 1 1 1 1 1 1 1 )
(1 1 1 1 1 1 1 1 1 1 1 1 1 1 ) 
(1 1 1 1 1 1 1 1 1 1 1 1 1 1 ) 
(1 1 1 1 1 1 1 1 0 0 1 1 1 1 ) 
(1 1 1 0 0 1 1 0 0 0 0 1 1 1 ) 
(1 1 1 0 0 0 0 0 1 1 0 1 1 1 ) 
(1 1 1 1 0 0 0 1 1 1 1 1 1 1 ) 
(1 1 1 1 1 1 1 1 0 0 1 1 1 1 ) 
(1 1 1 0 0 1 1 0 0 0 0 1 1 1 ) 
(1 1 1 0 0 0 0 0 1 1 0 1 1 1 ) 
(1 1 1 1 0 0 0 1 1 1 1 1 1 1 ) 
(1 1 1 1 1 1 1 1 1 1 1 1 1 1 ) 
(1 1 1 1 1 1 1 1 1 1 1 1 1 1 )
(1 1 1 1 1 1 1 1 1 1 1 1 1 1 )));14

  (call-next-method w x y width height :title title :draw draw)
  self)




(defmeth icon-proto :draw-trans-hi-icon (&optional medium-hi-icon)
        (send self :draw-trans-icon t medium-hi-icon))

(defmeth icon-proto :draw-model-hi-icon (&optional medium-hi-icon)
        (send self :draw-model-icon t medium-hi-icon))

(defmeth icon-proto :draw-graph-hi-icon (&optional medium-hi-icon)
        (send self :draw-graph-icon t medium-hi-icon))

(defmeth icon-proto :draw-stats-hi-icon (&optional medium-hi-icon)
        (send self :draw-stats-icon t medium-hi-icon))

(defmeth icon-proto :draw-model-icon (&optional hi ever-shown? (solid t))
  (unless (= 3 (send self :icon-type))
          (let* ((button "model")
                 (x (+ (send self :x) 27)) ;31
                 (y (+ (send self :y) 17)));17
    ;(send self :draw-arrow (- x 6) (+ y 3) t)
     (send self :draw-icon-button button x y hi ever-shown?))))

(defmeth icon-proto :draw-trans-icon (&optional hi ever-shown? (solid t))
  (unless (= 3 (send self :icon-type))
          (let* ((button "trans")
                 (x (- (send self :x) 17)) ;21
                 (y (+ (send self :y) 17)))
           ; (send self :draw-arrow (+ x 15) (+ y 3) nil)
            (send self :draw-icon-button button x y hi ever-shown?)
            )))

(defmeth icon-proto :draw-stats-icon (&optional hi ever-shown? (solid t))
  (let* ((model (= 3 (send self :icon-type)))
         (button "stats")
         (x (- (send self :x) 17)) ;21
         (y (+ (send self :y) (if model 15 0)))) ;15 0
   ; (send self :draw-arrow (+ x 15) (+ y (if model 3 10)) nil)
    (send self :draw-icon-button button x y hi ever-shown?)))

(defmeth icon-proto :draw-graph-icon (&optional hi ever-shown? (solid t))
  (let* ((model (= 3 (send self :icon-type)))
         (button "graph")
         (x (+ (send self :x) 27)) ;27
         (y (+ (send self :y) (if model 15 0)))) ;15 0
    ;(send self :draw-arrow (- x 6) (+ y (if model 3 10)) t)
    (send self :draw-icon-button button x y hi ever-shown?)))

(defmeth icon-proto :draw-arrow (x y lr)
  (let* ((w (send self :window))
         (c (if lr 1 -1))
         (d 3)
         (x+d (if lr x (+ x d)))
         )
    (send w :draw-color 'black)
    (send w :frame-poly (list (list (if lr x (+ x 2 d)) y)
                              (list (* c (+ 2 d)) 0)
                              (list (- (* c d)) d)
                              (list 0  (* -2 d))
                              (list (* c d) d)) nil)
    ))

(defmeth icon-proto :draw-icon-button (button button-x button-y hi ever-shown?)
"draws icon button at location button-x, button-y. is "
        (let* ((w (send self :window))
               (x (send self :x))
               (y (send self :y))
               (dc (send w :draw-color))
               (bc (send w :back-color))
               (ic (send self :icon-color))
               (es (send self :graph-ever-shown?))
               (ns (send self :graph-not-showable))
               (ears? (send w :show-icon-ears?))
               (new-style? (send w :new-icon-style?))
               (trs (equal button "trans") )
               (mod (equal button "model") )
               (sts (equal button "stats") )
               (grf (equal button "graph") )
               )
          (when (= 3 (send self :icon-type)) (send self :icon-color 'model-icon-color))
          (when (member (send self :icon-type) '(1 4 5)) (send self :icon-color 'data-icon-color))
      #|  (cond
            (;(and ever-shown? (not (equal (send w :selected-icon-object) self)))
             (and ever-shown? (not hi))
             (send w :draw-color 'black)
             (send w :back-color 'medium-blue))
            ((not (equal (send w :selected-icon-object) self))
             (send w :draw-color 'medium-gray)
             (send w :back-color 'white))
            (hi
             (send w :draw-color 'black)
             (send w :back-color (send self :icon-color)))
            (t
             (send w :draw-color (send self :icon-color))
             (send w :back-color 'white)))
      |#  (cond
            (;(and ever-shown? (not (equal (send w :selected-icon-object) self)))
             (and ever-shown? (not hi))
             (send w :draw-color (send self :icon-color))
             (send w :back-color 'white))

            ((not (equal (send w :selected-icon-object) self))
             (send w :draw-color 'medium-gray)
             (send w :back-color 'white))

            (hi
             (send w :draw-color 'black)
             (send w :back-color (send self :icon-color)))
            (t
             (send w :draw-color 'medium-gray)
             (send w :back-color 'white)))
          (send self :draw-side-icon 
                (cond
                  (trs (cond
                         (ns
                          (send w :draw-color 'never-shown-color)
                          (send self :graph-stats-grey-icon))
                         (t
                          (if hi (send self :trans-hi-icon)(send self :trans-icon)))))
                  (mod (if hi (send self :model-hi-icon)(send self :model-icon)))
                  (sts (if hi (send self :stats-hi-icon)(send self :stats-icon)))
                  (grf (cond
                         (ns
                          (send w :draw-color 'never-shown-color)
                            (send self :graph-stats-grey-icon))
                         (t
                          (if hi (send self :graph-hi-icon)(send self :graph-icon)))))
                  (t))
                button-x button-y w hi)
          (send w :back-color bc)
          (send w :draw-color dc)
          t))



(defmeth icon-proto :draw-side-icon  (icon x y win &optional hi)
  (let* ((sizes (array-dimensions icon))
         (h (first sizes))
         (w (second sizes))
         (dc (send win :draw-color))
         (bc (send win :back-color))
         (row (matrix (list 1 w) (repeat 1 w)))
         (col (matrix (list h 1) (repeat 1 h))))
    (when hi (send win :draw-color bc) 
          (send win :back-color dc))
    ;  (t (send win :draw-color 'medium-blue))

    (send win :draw-bitmap icon x y)
    (send win :draw-color  'black)
    (send win :frame-rect x y w h)
    (send win :draw-line (+ x w) (+ y 1) (+ x w) (+ y h 1))
    (send win :draw-line (+ x 1) (+ y h) (+ x w 1) (+ y h))
    (send win :back-color bc)
    (send win :draw-color dc)))



